home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / svgadc30.zip / svgamap.pas < prev    next >
Pascal/Delphi Source File  |  1993-03-03  |  19KB  |  733 lines
  1. program SVGA_Bitmap_Maker;
  2.  
  3. {  Use mouse to choose color and draw image      }
  4. {  The followig keys can be used as follows      }
  5. {  'Q' - No nonsense quit                        }
  6. {  'S' - Save image to disk.  Will be prompted   }
  7. {        for a filename.                         }
  8. {  'L' - Load image from disk. Will be prompted  }
  9. {        for a filename.                         }
  10. {  'P' - Change width of each pixel element of   }
  11. {        drawing. Range 1..9                     }
  12. {  'N' - New image. Clears present image from    }
  13. {        memory.  Prompts for 'Y' or 'N'         }
  14. {  'C' - Change image size.  Will delete present }
  15. {        image from memory and start with new    }
  16. {        sized image.  Image dimensions are      }
  17. {        measured in pixels.  If not enough      }
  18. {        memory on heap image size will not      }
  19. {        be allowed.                             }
  20. {  'M' - Move image around screen to get at      }
  21. {        hard to reach places.  Press escape     }
  22. {        when done.                              }
  23. {  'X' - Load a palette from disk.  Prompts for  }
  24. {        filename.                               }
  25. {  'E' - Left over from development of this      }
  26. {        program.  Simply puts image to screen   }
  27. {        whereever mouse pointer is.             }
  28. {  If you want to exit from 'load' , 'save' etc  }
  29. {  without the program doing anything simply     }
  30. {  press enter with no input i.e. null string '' }
  31.  
  32. uses SVGA, Crt;
  33.  
  34. type YPtr = ^YType;
  35.      YType = record
  36.                Col1, Col2, Col3, Col4 : byte; { Due to TP's memory }
  37.                NextY : YPtr;                  { memory management }
  38.              end;                             { pointers are multiples}
  39.      XPtr = ^XType;                           { of 8 bytes }
  40.      XType = record
  41.                NextX : XPtr;
  42.                Y : YPtr;
  43.              end;
  44.  
  45. var GM : GraphicMouse;
  46.     Vx, Vy, PixelWidth, XPos, YPos, Btn, TX, TY, Bx, By : integer;
  47.     ActiveColor, MaxHeight, MaxWidth : byte;
  48.     XCoord, YCoord, resp, ImageName, PaletteName : string;
  49.     Quit : boolean;
  50.     Ch : char;
  51.     Image : XPtr;
  52.     HeapMem : longint;
  53.  
  54. procedure PutImage( x, y : integer; Img : XPtr );
  55.  
  56.   var xx, yy : integer;
  57.       Offset, bank : longint;
  58.  
  59.  
  60.   procedure TraverseYPtr( Yp : YPtr );
  61.  
  62.     begin
  63.       if Yp <> nil then
  64.         begin
  65.  
  66.           Bank := Offset shr 16;
  67.           if Bank <> PresentSeg then LoadWriteBank( Bank );
  68.           MEM[$A000:Offset] := Yp^.Col1;
  69.  
  70.           inc( Offset, Bytes_per_line );
  71.           Bank := Offset shr 16;
  72.           if Bank <> PresentSeg then LoadWriteBank( Bank );
  73.           MEM[$A000:Offset] := Yp^.Col2;
  74.  
  75.           inc( Offset, Bytes_per_line );
  76.           Bank := Offset shr 16;
  77.           if Bank <> PresentSeg then LoadWriteBank( Bank );
  78.           MEM[$A000:Offset] := Yp^.Col3;
  79.  
  80.           inc( Offset, Bytes_per_line );
  81.           Bank := Offset shr 16;
  82.           if Bank <> PresentSeg then LoadWriteBank( Bank );
  83.           MEM[$A000:Offset] := Yp^.Col4;
  84.  
  85.           inc( Offset, Bytes_per_line );
  86.           inc( yy, 4 );
  87.           TraverseYPtr( Yp^.NextY );
  88.         end;
  89.     end;
  90.  
  91.   procedure TraverseXPtr( Xp : XPtr );
  92.  
  93.     begin
  94.       if Xp <> nil then
  95.         begin
  96.           Offset := (longint(yy)*Bytes_per_line)+xx;
  97.           TraverseYPtr( Xp^.Y );
  98.           yy := y;
  99.           inc( xx );
  100.           TraverseXPtr( Xp^.NextX );
  101.         end;
  102.     end;
  103.  
  104.   begin
  105.     xx := x;
  106.     yy := y;
  107.     TraverseXPtr( Img );
  108.   end;
  109.  
  110. procedure SaveImage( Img : XPtr );
  111.  
  112.   var f : file of byte;
  113.  
  114.   procedure TraverseYPtr( Yp : YPtr );
  115.  
  116.     begin
  117.       if Yp <> nil then
  118.         begin
  119.           write( f, Yp^.Col1 );
  120.           write( f, Yp^.Col2 );
  121.           write( f, Yp^.Col3 );
  122.           write( f, Yp^.Col4 );
  123.           TraverseYPtr( Yp^.NextY );
  124.         end;
  125.     end;
  126.  
  127.   procedure TraverseXPtr( Xp : XPtr );
  128.  
  129.     begin
  130.       if Xp <> nil then
  131.         begin
  132.           TraverseYPtr( Xp^.Y );
  133.           TraverseXPtr( Xp^.NextX );
  134.         end;
  135.     end;
  136.  
  137.   begin
  138.     assign( f, imagename );
  139.     rewrite( f );
  140.     write( f, MaxWidth, MaxHeight );
  141.     TraverseXPtr( Img );
  142.     close( f );
  143.   end;
  144.  
  145. procedure DrawImage;
  146.  
  147.   var xx, yy, vvx, vvy : integer;
  148.  
  149.   procedure TraverseYPtr( Yp : YPtr );
  150.  
  151.     procedure PlotCol( c : byte; x: integer; var y : integer );
  152.  
  153.       begin
  154.         if yy < By then
  155.           begin
  156.             RectFill( x*PixelWidth, y*PixelWidth, x*PixelWidth+PixelWidth-1,
  157.                       y*PixelWidth+PixelWidth-1, c );
  158.             if (500+x < GetMaxX) and (300+y < GetmaxY) then
  159.                 Plot( 500+x, 300+y, c );
  160.             inc( y );
  161.           end;
  162.       end;
  163.  
  164.     begin
  165.       if vvy >= Vy then
  166.         begin
  167.           if (Yp <> nil) then
  168.             begin
  169.               PlotCol( Yp^.Col1, xx, yy );
  170.               PlotCol( Yp^.Col2, xx, yy );
  171.               PlotCol( Yp^.Col3, xx, yy );
  172.               PlotCol( Yp^.Col4, xx, yy );
  173.               TraverseYPtr( Yp^.NextY );
  174.             end;
  175.         end
  176.       else
  177.         begin
  178.           inc( vvy, 4 );
  179.           if Yp <> nil then TraverseYPtr( Yp^.NextY );
  180.         end
  181.     end;
  182.  
  183.   procedure TraverseXPtr( Xp : XPtr );
  184.  
  185.     begin
  186.       if vvx >= Vx then
  187.         begin
  188.           if (Xp <> nil) and (xx < Bx) then
  189.             begin
  190.               TraverseYPtr( Xp^.Y );
  191.               yy := 0; vvy := 0;
  192.               inc( xx );
  193.               TraverseXPtr( Xp^.NextX );
  194.             end;
  195.         end
  196.       else
  197.         begin
  198.           inc( vvx );
  199.           if Xp <> nil then TraverseXPtr( Xp^.NextX );
  200.         end;
  201.     end;
  202.  
  203.   begin
  204.     GM.Show( False );
  205.     ClearPort( 0, 0, GetMaxX-140, GetMaxY );
  206.     RectFill( 500,300,GetMaxX, GetMaxY, 0 );
  207.     xx := 0; vvx := 0;
  208.     yy := 0; vvy := 0;
  209.     TraverseXPtr( Image );
  210.     GM.Show( True );
  211.   end;
  212.  
  213. procedure LoadImage( var ImagePtr : XPtr );
  214.  
  215.   var f : file of byte;
  216.       Col1, Col2, Col3, Col4, th : byte;
  217.  
  218.   procedure ReadY( var Yp : YPtr );
  219.  
  220.     var TmpY : YPtr;
  221.  
  222.     begin
  223.       new( TmpY );
  224.       read( f, Col1, Col2, Col3, Col4 );
  225.       TmpY^.Col1 := Col1;
  226.       TmpY^.Col2 := Col2;
  227.       TmpY^.Col3 := Col3;
  228.       TmpY^.Col4 := Col4;
  229.       inc( th, 4 );
  230.       if th < MaxHeight then
  231.         ReadY( TmpY^.NextY )
  232.       else
  233.         TmpY^.NextY := nil;
  234.       Yp := TmpY;
  235.     end;
  236.  
  237.   procedure ReadX( var Xp : XPtr );
  238.  
  239.     var TmpX : XPtr;
  240.  
  241.     begin
  242.       if not eof( f ) then
  243.         begin
  244.           new( TmpX );
  245.           ReadY( TmpX^.Y );
  246.           th := 1;
  247.           ReadX( TmpX^.NextX );
  248.           Xp := TmpX;
  249.         end
  250.       else
  251.         Xp := nil;
  252.     end;
  253.  
  254.   begin
  255.     assign( f, ImageName );
  256.     reset( f );
  257.     read( f, MaxWidth, MaxHeight );
  258.     th := 1;
  259.     ReadX( ImagePtr );
  260.     close( f );
  261.   end;
  262.  
  263. procedure SetImageCol( x, y, NewCol : byte; var Img : XPtr );
  264.  
  265.   var xx, yy : byte;
  266.  
  267.   procedure TraverseYPtr( var Yp : YPtr );
  268.  
  269.     function ic( var t : byte ): byte;
  270.  
  271.       begin
  272.         inc( t );
  273.         ic := t;
  274.       end;
  275.  
  276.     begin
  277.       if Yp <> nil then
  278.         begin
  279.            if yy = y then Yp^.Col1 := NewCol
  280.              else if ic(yy) = y then Yp^.Col2 := NewCol
  281.                else if ic(yy) = y then Yp^.Col3 := NewCol
  282.                  else if ic(yy) = y then Yp^.Col4 := NewCol
  283.                    else
  284.                      begin
  285.                        inc( yy );
  286.                        TraverseYPtr( Yp^.NextY );
  287.                      end;
  288.         end;
  289.     end;
  290.  
  291.   procedure TraverseXPtr( var Xp : XPtr );
  292.  
  293.     begin
  294.       if Xp <> nil then
  295.         begin
  296.           if xx = x then
  297.             TraverseYPtr( Xp^.Y )
  298.           else
  299.             begin
  300.               inc( xx );
  301.               TraverseXPtr( Xp^.NextX );
  302.             end
  303.         end;
  304.     end;
  305.  
  306.   begin
  307.     xx := 0;
  308.     yy := 0;
  309.     TraverseXPtr( Img );
  310.   end;
  311.  
  312. procedure ClearMemory( var Img : XPtr );
  313.  
  314.   procedure TraverseYPtr( Yp : YPtr );
  315.  
  316.     begin
  317.       if Yp <> nil then
  318.         begin
  319.           Yp^.Col1 := 0;
  320.